home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Mode Examples / Tcl-Example.tcl < prev    next >
Encoding:
Text File  |  2000-10-30  |  38.2 KB  |  1,317 lines
  1. ## -*-Tcl-*-
  2.  # # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "tclMode.tcl"
  6.  #                                    created: 5/4/97 {9:31:10 pm} 
  7.  #                                last update: 10/18/00 {11:21:29 am} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta
  11.  #          Santa Fe, NM 87501, USA
  12.  #     www: <http://www.santafe.edu/~vince/>
  13.  #  
  14.  # Copyright (c) 1997-2000 Vince Darley
  15.  #  
  16.  # Three procs from original: Tcl::DblClick listArray, getVarValue
  17.  #    
  18.  # Adds support for Tk, Itcl keywords and completions, plus 
  19.  # numerous fixes, improvements and integration with Vince's
  20.  # Additions.
  21.  # ###################################################################
  22.  ##
  23.  
  24. # Since this is included only for mode demonstration purposes, we make sure
  25. # that it never gets loaded.
  26. error "The \"Tcl-Example.tcl\" file should never be loaded !!"
  27.  
  28. alpha::mode Tcl 1.8.4 tclMenu {*.tcl *.itcl *.itk *.tbc tclIndex*} {
  29.     tclMenu electricTab electricReturn electricBraces alphaDeveloperMenu
  30. } {
  31.     addMenu tclMenu "•269" "Tcl" "Tcl menu\r\rnot very obvious..."
  32.     set unixMode(wish) {Tcl}
  33.     set unixMode(tclsh) {Tcl}
  34.     set unixMode(itclsh) {Tcl}
  35.     set unixMode(itkwish) {Tcl}
  36.     set unixMode(prowish) {Tcl}
  37.     set unixMode(protclsh) {Tcl}
  38.     ensureset tclshSig "WIsH"
  39.     ensureset evaluateRemotely 0
  40.     trace variable evaluateRemotely w tcltk::evaluateRemoteSynchronise
  41.     menu::buildProc tclMenu menu::buildtclMenu
  42.     lappend tclColourings Tcl::colorTclKeywords \
  43.       Tcl::colorTkKeywords \
  44.       Tcl::colorItclKeywords Tcl::colorPseudoTclKeywords \
  45.       Tcl::colorTkCommands Tcl::colorSymbols
  46. } maintainer {
  47.     "Vince Darley" vince@santafe.edu <http://www.santafe.edu/~vince/>
  48. } uninstall this-file help {
  49.     This mode is for editing Tcl code.  You can edit code for internal
  50.     use with Alpha, or use Alpha as an external editor for code destined
  51.     for use with Tcl and Tk interpreters --- Sun distributes the Wish
  52.     application and a tcl-tk browser plugin.
  53.     
  54.     You can 'evaluate' a procedure (or any Tcl code for that matter) to 
  55.     make changes on the fly.  If you select 'Evaluate Remotely' in the 
  56.     tcl-tk submenu, then such actions will actually send the code
  57.     to a separately running Wish application to be evaluated.
  58. }
  59.  
  60. namespace eval tcltk {}
  61. proc tclMenu {} {}
  62.  
  63. # ◊◊◊◊ menu and prefs ◊◊◊◊ #
  64. # The menu.
  65. proc menu::buildtclMenu {} {
  66.     global tclMenu evaluateRemotely tcltk::executables
  67.     set execs {}
  68.     if {[info exists tcltk::executables]} {
  69.     lappend execs "\(-"
  70.     foreach ex ${tcltk::executables} {
  71.         lappend execs [file tail $ex]
  72.     }
  73.     }
  74.     set ma [list \
  75.       "/Levaluate" "/-<UswitchToTclsh" \
  76.       [list Menu -n "tcl-tk" -p tcltk::menuProc [concat [list \
  77.       "![lindex {{ } •} $evaluateRemotely]evaluateRemotely" \
  78.       executeCommand executeFileInRemoteShell addWindowToListOfExecutables] \
  79.       $execs]] \
  80.       "\(-" "/L<O<BreloadProc" "/I<O<BreformatProc" \
  81.       "rebuildTclIndexForWin" "\(-" \
  82.       "<U/PfindProcDefinition…" "/Q<IquickFindProc…" "getVarValue…" \
  83.       "/4<BaddRemoveDollars" "/3<BinsertDivider" \
  84.       "\(-" "regularExpressionColors" "defaultColors"]
  85.     return [list build $ma Tcl::MenuProc "" $tclMenu]
  86. }
  87. menu::buildSome tclMenu
  88.  
  89. #===============================================================================
  90. #
  91. # Set up package-specific mode variables
  92. # 
  93.  
  94. # Removing obsolete preferences from earlier versions.
  95. prefs::removeObsolete TclmodeVars(alphaKeyWordColor) TclmodeVars(keywordColor)
  96.  
  97. newPref v prefixString {# } Tcl
  98. newPref f wordWrap {0} Tcl
  99. newPref v funcExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
  100. newPref v parseExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
  101. newPref v wordBreak {(\$)?[\w:_]+} Tcl
  102. newPref v wordBreakPreface {([^\w:_\$]|.\$)} Tcl
  103. newPref f autoMark 0 Tcl
  104. # Indentation scheme for lines following one ending in a backslash
  105. newPref v indentSlashEndLines 1 Tcl "" indent::amounts varindex
  106. # Mark files structurally, recognising the special comments
  107. # entered by 'ctrl-3'
  108. newPref f structuralMarks 0 Tcl
  109.  
  110. set Tcl::startPara {^(.*\{)?[ \t]*(#|$)}
  111. set Tcl::endPara {^(.*\})?[ \t]*(#|$)}
  112. set Tcl::commentRegexp {^[ \t]*#}
  113.  
  114. # Not sure if this is used by completions still...
  115. set Tclcmds { append array catch close concat continue elseif error
  116. for foreach format lindex llength lrange lreplace lsearch lsort regexp 
  117. regsub rename return string switch while }
  118.  
  119. #===============================================================================
  120. #
  121. # Colorization setup
  122. #
  123.  
  124. # Colour Tk commands
  125. newPref f recogniseTk        {1}    Tcl    {Tcl::updateColors}
  126. # Colour [incr Tcl] commands
  127. newPref f recogniseItcl        {1}    Tcl    {Tcl::updateColors}
  128. # Recognise and colour some common procedures 'lunion' etc.
  129. newPref f recognisePseudoTcl    {1}    Tcl    {Tcl::updateColors}
  130. # Colour of all chosen commands.
  131. newPref v commandColor        {blue}    Tcl    {Tcl::updateColors}
  132. # Color for Tcl comments
  133. newPref v commentColor        {red}    Tcl    {Tcl::updateColors}
  134. # Colour of the $ magic character.
  135. newPref v magicColor        {black}    Tcl    {Tcl::updateColors}
  136. # Colour for strings
  137. newPref v stringColor        {green}    Tcl    {Tcl::updateColors}
  138. # Colour of symbols such as \, -, +, *, etc.  Can be useful for
  139. # reading regular expressions.
  140. newPref v symbolColor        {black}    Tcl    {Tcl::updateColors}
  141.  
  142. ## 
  143.  # -------------------------------------------------------------------------
  144.  # 
  145.  # "Tcl::_updateKeywords" --
  146.  # 
  147.  #  This proc now includes support for optional separate colorization of 
  148.  #  alpha commands. To use, set 'alphaKeyWordColor' to something other than 
  149.  #  'none' in the Tcl Mode Preferences dialog. -trf
  150.  # -------------------------------------------------------------------------
  151.  # 
  152.  # Now split into a series of procs, called in the end by colorizeTcl.  -cbu
  153.  # 
  154.  # -------------------------------------------------------------------------
  155.  ##
  156.  
  157. #===============================================================================
  158. #
  159. # Color procs begin here #
  160. #
  161.  
  162.  
  163. #===============================================================================
  164. #
  165. # Color Tcl Keywords
  166. #
  167.  
  168. proc Tcl::colorTclKeywords {} {
  169.     global TclmodeVars
  170.  
  171.     # all except beep and echo are basic Tcl keywords
  172.  
  173.     set tclKeyWords {
  174.     after append array auto_execok auto_import auto_load
  175.     auto_load_index auto_qualify beep binary break case catch cd clock
  176.     close concat continue dde default echo else elseif encoding eof
  177.     error eval exec exit expr fblocked fconfigure fcopy file
  178.     fileevent flush for foreach format gets glob global history if
  179.     incr info interp join lappend lindex linsert list llength load
  180.     lrange lreplace lsearch lsort namespace open package pid
  181.     pkg_mkIndex proc puts pwd read regexp regsub rename resource
  182.     return scan seek set socket source split string subst switch
  183.     tclLog tclMacPkgSearch tclPkgSetup tclPkgUnknown tell time
  184.     trace unknown unset update uplevel upvar variable vwait while
  185.     }
  186.     
  187.     regModeKeywords -a                \
  188.       -e {#} -c $TclmodeVars(commentColor)      \
  189.       -s $TclmodeVars(stringColor)              \
  190.       -k $TclmodeVars(commandColor) Tcl      \
  191.       $tclKeyWords 
  192.  
  193. }
  194.  
  195.  
  196.  
  197.  
  198. #===============================================================================
  199. #
  200. # Color Tk Keywords
  201. #
  202.  
  203. proc Tcl::colorTkKeywords {} {
  204.     global TclmodeVars
  205.  
  206.     set tkKeyWords {
  207.     bell bind bindtags button canvas checkbutton console destroy
  208.     entry event focus font frame grab grid image label listbox menu
  209.     menubutton message pack place radiobutton raise scale scrollbar
  210.     text tk tkwait toplevel winfo wm
  211.     }
  212.  
  213.     if {$TclmodeVars(recogniseTk)} {
  214.      regModeKeywords -a             \
  215.       -k $TclmodeVars(commandColor) Tcl    \
  216.       $tkKeyWords
  217.     } else {
  218.      regModeKeywords -a             \
  219.       -k {black} Tcl            \
  220.       $tkKeyWords
  221.     }
  222. }
  223.  
  224.  
  225. #===============================================================================
  226. #
  227. # Color iTcl Keywords
  228. #
  229.  
  230. proc Tcl::colorItclKeywords {} {
  231.     global TclmodeVars
  232.  
  233.     set itclKeyWords {
  234.     @scope body class code common component configbody constructor
  235.     define destructor hull import inherit itcl itk itk_component
  236.     itk_initialize itk_interior itk_option iwidgets keep method
  237.     private protected public
  238.     }
  239.  
  240.     if {$TclmodeVars(recogniseItcl)} {
  241.     regModeKeywords -a                 \
  242.      -k $TclmodeVars(commandColor) Tcl         \
  243.      $itclKeyWords
  244.    } else {
  245.     regModeKeywords -a                 \
  246.      -k {black} Tcl                     \
  247.      $itclKeyWords
  248.    }
  249. }
  250.  
  251.  
  252. #===============================================================================
  253. #
  254. # Color Pseudo Tcl Keywords
  255. #
  256.  
  257. proc Tcl::colorPseudoTclKeywords {} {
  258.     global TclmodeVars
  259.     
  260.     set PseudoTclKeywords { 
  261.     lcontains lunion lreverse lremove lunique
  262.     }
  263.     if {$TclmodeVars(recogniseTk)} {
  264.     regModeKeywords -a                 \
  265.      -k $TclmodeVars(commandColor) Tcl         \
  266.      $PseudoTclKeywords
  267.     } else {
  268.     regModeKeywords -a                 \
  269.      -k {black} Tcl                     \
  270.      $PseudoTclKeywords
  271.     }
  272.     
  273. }
  274.  
  275.  
  276. #===============================================================================
  277. #
  278. # Color Tk Commands
  279. #
  280. # add this line if we can handle double 'magic chars'
  281. # -m {tk} 
  282. #
  283.  
  284. proc Tcl::colorTkCommands {} {
  285.     
  286.     global TclmodeVars
  287.  
  288.     set TkCommands {
  289.     tkButtonDown tkButtonEnter tkButtonInvoke tkButtonLeave tkButtonUp
  290.     tkCancelRepeat tkCheckRadioInvoke tkDarken tkEntryAutoScan
  291.     tkEntryBackspace tkEntryButton1 tkEntryClosestGap tkEntryInsert
  292.     tkEntryKeySelect tkEntryMouseSelect tkEntryNextWord tkEntryPaste
  293.     tkEntryPreviousWord tkEntrySeeInsert tkEntrySetCursor
  294.     tkEntryTranspose tkEventMotifBindings tkFDGetFileTypes tkFirstMenu
  295.     tkFocusGroup_BindIn tkFocusGroup_BindOut tkFocusGroup_Create
  296.     tkFocusGroup_Destroy tkFocusGroup_In tkFocusGroup_Out tkFocusOK
  297.     tkListboxAutoScan tkListboxBeginExtend tkListboxBeginSelect
  298.     tkListboxBeginToggle tkListboxCancel tkListboxDataExtend
  299.     tkListboxExtendUpDown tkListboxMotion tkListboxSelectAll
  300.     tkListboxUpDown tkMbButtonUp tkMbEnter tkMbLeave tkMbMotion
  301.     tkMbPost tkMenuButtonDown tkMenuDownArrow tkMenuDup tkMenuEscape
  302.     tkMenuFind tkMenuFindName tkMenuFirstEntry tkMenuInvoke tkMenuLeave
  303.     tkMenuLeftArrow tkMenuMotion tkMenuNextEntry tkMenuNextMenu
  304.     tkMenuRightArrow tkMenuUnpost tkMenuUpArrow tkMessageBox
  305.     tkPostOverPoint tkRecolorTree tkRestoreOldGrab tkSaveGrabInfo
  306.     tkScaleActivate tkScaleButton2Down tkScaleButtonDown
  307.     tkScaleControlPress tkScaleDrag tkScaleEndDrag tkScaleIncrement
  308.     tkScreenChanged tkScrollButton2Down tkScrollButtonDown
  309.     tkScrollButtonUp tkScrollByPages tkScrollByUnits tkScrollDrag
  310.     tkScrollEndDrag tkScrollSelect tkScrollStartDrag tkScrollToPos
  311.     tkScrollTopBottom tkTabToWindow tkTearOffMenu tkTextAutoScan
  312.     tkTextButton1 tkTextClosestGap tkTextInsert tkTextKeyExtend
  313.     tkTextKeySelect tkTextNextPara tkTextNextPos tkTextNextWord
  314.     tkTextPaste tkTextPrevPara tkTextPrevPos tkTextResetAnchor
  315.     tkTextScrollPages tkTextSelectTo tkTextSetCursor tkTextTranspose
  316.     tkTextUpDownLine tkTraverseToMenu tkTraverseWithinMenu tk_bisque
  317.     tk_chooseColor tk_dialog tk_focusFollowsMouse tk_focusNext
  318.     tk_focusPrev tk_getOpenFile tk_getSaveFile tk_messageBox
  319.     tk_optionMenu tk_popup tk_setPalette tk_textCopy tk_textCut
  320.     tk_textPaste
  321.     }
  322.     
  323.     if {$TclmodeVars(recogniseTk)} {
  324.     regModeKeywords -a             \
  325.      -k $TclmodeVars(commandColor) Tcl     \
  326.      $TkCommands
  327.     } else {
  328.     regModeKeywords -a             \
  329.      -k {black} Tcl             \
  330.      $TkCommands   
  331.  
  332.     }
  333.     unset TkCommands    
  334. }
  335.  
  336.     
  337. #===============================================================================
  338. #
  339. # Color Symbols and Magic Character
  340. # 
  341.  
  342. proc Tcl::colorSymbols {} {
  343.     
  344.     global TclmodeVars
  345.     
  346.     regModeKeywords -a                 \
  347.       -m {$}                    \
  348.       -k $TclmodeVars(magicColor) Tcl {}    \
  349.       -i "+" -i "-" -i "*" -i "_" -i "\\"    \
  350.       -I $TclmodeVars(symbolColor)  
  351. }
  352.  
  353.  
  354. #===============================================================================
  355. #
  356. # Colorize Tcl
  357. # 
  358.  
  359. proc Tcl::colorizeTcl {} {
  360.     global tclColourings
  361.     foreach p $tclColourings {
  362.     $p
  363.     }
  364.     refresh
  365. }
  366.  
  367. # This is a "dummy" command, necessary for the above proc so that all of
  368. # the "regModeKeywords" commands in the called color procs can be "adds"
  369. # (-a).  When the mode is first invoked, this has to occur before the color
  370. # procs are called.
  371.  
  372. regModeKeywords -k {none} Tcl {}
  373.  
  374. # now we finally colorize
  375.  
  376. Tcl::colorizeTcl
  377.  
  378.     
  379. #===============================================================================
  380. #
  381. # Tcl:: Update Colors -- 
  382. # 
  383. # This allows for changes to take effect without a restart.
  384. # 
  385. # Danger:  Don't include this proc in any {mode}Prefs.tcl file !!!
  386. # 
  387. # This will source the prefs file, and thus put Alpha in an endless loop.
  388. # Instead, use the  Tcl::colorizeTcl  proc in the prefs file, so that
  389. # "Load Prefs File" will update any local variables.     - cbu
  390. # 
  391.  
  392.  
  393. proc Tcl::updateColors {flag} {
  394.     
  395.     global mode PREFS $flag TclmodeVars 
  396.     
  397.     # If the mode has a {mode}Prefs.tcl file, we want to load that as 
  398.     # well, otherwise any keywords contained therein won't be updated
  399.     # without a manual "Load Prefs File".
  400.     
  401.     if {[file exists [file join ${PREFS} ${mode}Prefs.tcl]]} {
  402.     uplevel #0 [list source [file join ${PREFS} ${mode}Prefs.tcl]]
  403.     } 
  404.  
  405.     Tcl::colorizeTcl
  406. }
  407.  
  408. #===============================================================================
  409. #
  410. # Regular Expression Colors --
  411. # 
  412. # Changes color scheme of current window to make it easier to read regular
  413. # expressions.  Preferences aren't actually changed.  "defaultColors" will
  414. # restore to the last stored values of the colors.  -cbu
  415. # 
  416.  
  417. proc Tcl::regularExpressionColors {} {
  418.     
  419.     regModeKeywords -a                 \
  420.       -e {}                    \
  421.       -m {$}                    \
  422.       -s {black}                \
  423.       -k {magenta} Tcl {}            \
  424.       -i "+" -i "-" -i "*" -i "_" -i "\\"    \
  425.       -I {red}  
  426.     
  427.     refresh
  428. }
  429.  
  430. proc Tcl::defaultColors {} {Tcl::colorizeTcl}
  431.     
  432.  
  433. # ???? end of keyword colorizing ???? #
  434.  
  435. #===============================================================================
  436.  
  437.  
  438. proc Tcl::MenuProc {menu item} {
  439.     switch -glob $item {
  440.     "reformatProc" {
  441.         procs::reformatEnclosing [getPos]
  442.     }
  443.     "reloadProc" {
  444.         procs::loadEnclosing [getPos]
  445.     }
  446.     "findProcDefinition" {
  447.         procs::findDefinition
  448.     }
  449.     "quickFindProc" {
  450.         # use the status line
  451.         procs::quickFindDefn
  452.     }
  453.     "switch*" {
  454.         set v "[string tolower [string range $item 8 end]]Sig"
  455.         global $v
  456.         app::launchFore [set $v]
  457.     }
  458.     "addRemoveDollars" {
  459.         togglePrefix \$
  460.     }
  461.     default {
  462.         menu::generalProc Tcl $item 0
  463.     }
  464.     }
  465. }
  466.  
  467. ## 
  468.  # -------------------------------------------------------------------------
  469.  # 
  470.  # "Tcl::rebuildTclIndexForWin" --
  471.  # 
  472.  #  If the file is in Alpha's source tree, use the currently loaded
  473.  #  auto_mkindex.  If it is not, then fire up a separate Tcl application
  474.  #  and use its auto_mkindex (i.e. the standard Tcl one).  It just occured
  475.  #  to me that for Tcl >= 8.0, we could create a new interp, and 
  476.  #  execute auto_mkindex within that to the same effect, but without
  477.  #  the overhead of a whole new process (especially a Tk one!).
  478.  # -------------------------------------------------------------------------
  479.  ##
  480. proc Tcl::rebuildTclIndexForWin {} {
  481.     if {[alpha::inAlphaHierarchy [win::Current]]} {
  482.     auto_mkindex [file dirname [win::Current]]
  483.     auto_reset
  484.     } else {
  485.     # This will currently launch a Tk shell, which isn't ideal.
  486.     set dir [file dirname [win::Current]]
  487.     tcltk::launchNewShell "auto_mkindex $dir" "exit"
  488.     }
  489. }
  490.  
  491. proc tcltk::menuProc {menu item} {
  492.     global tcl_platform tclshSig
  493.     switch -- $item {
  494.     "evaluateRemotely" {
  495.         global evaluateRemotely
  496.         set evaluateRemotely [expr {1 - $evaluateRemotely}]
  497.     }
  498.     "executeFileInRemoteShell" {
  499.         tcltk::executeInRemoteShell [win::Current]
  500.     }
  501.     "addWindowToListOfExecutables" {
  502.         global tcltk::executables
  503.         lappend tcltk::executables [win::Current]
  504.         prefs::modified tcltk::executables
  505.         menu::buildSome tclMenu
  506.     }
  507.     "executeCommand" {
  508.         set cmd [getline "Please enter the script to send to tcl-tk"]
  509.         if {$cmd == ""} {return}
  510.         if {$tcl_platform(platform) == "macintosh"} {
  511.         set res [AEBuild -r -t 30000 '$tclshSig' misc dosc ---- "“$cmd”"]
  512.         } else {
  513.         set res [tcltk::evaluate $cmd]
  514.         }
  515.         alertnote "Result was '$res'"
  516.     }
  517.     default {
  518.         global tcltk::executables
  519.         foreach ex ${tcltk::executables} {
  520.         if {[file tail $ex] == $item} {
  521.             tcltk::executeInRemoteShell $ex
  522.             break
  523.         }
  524.         }
  525.     }
  526.     }
  527. }
  528.  
  529. proc tcltk::executeInRemoteShell {f} {
  530.     global evaluateRemotely
  531.     set realName [stripNameCount $f]
  532.     tcltk::launchNewShell \
  533.       "cd [file dirname $realName]" \
  534.       "source [file tail $realName]"
  535.     if {!$evaluateRemotely} {
  536.     set evaluateRemotely 1
  537.     }
  538. }
  539.  
  540. proc tcltk::evaluateRemoteSynchronise {args} {
  541.     global evaluateRemotely tclMenu
  542.     catch {markMenuItem "tcl-tk" evaluateRemotely $evaluateRemotely}
  543.     if {$evaluateRemotely} {
  544.     if {[info commands notRemoteEvaluate] == ""} {
  545.         rename evaluate notRemoteEvaluate
  546.         ;proc evaluate {} {remoteEvaluate}
  547.     }
  548.     menu::replaceRebuild tclMenu "•320"
  549.     } else {
  550.     if {[info commands notRemoteEvaluate] != ""} {
  551.         rename evaluate {}
  552.         rename notRemoteEvaluate evaluate
  553.     }
  554.     menu::replaceRebuild tclMenu "•269"
  555.     }
  556. }
  557.  
  558.  
  559. proc remoteEvaluate {} {
  560.     message "Remote reply: [tcltk::evaluate [getSelect]]"
  561. }
  562.  
  563. proc tcltk::evaluate {what} {
  564.     global tclshSig tcl_platform
  565.     if {$tcl_platform(platform) == "macintosh"} {
  566.     app::ensureRunning $tclshSig
  567.     if {[catch {set r [tclAE::build::resultData -t 30000 '${tclshSig}' \
  568.                 misc dosc \
  569.               ---- [tclAE::build::TEXT $what] \
  570.             ]} res]} {
  571.         set res "Error: $res"
  572.     }            
  573.     #catch {dosc -c '${tclshSig}' -s $what} res
  574.     #return $res
  575.     } else {
  576.     global tclshInterp
  577.     if {![info exists tclshInterp]} {
  578.         if {[catch {tcltk::findTclshInterp}]} {
  579.         return "No shell selected"
  580.         }
  581.     }
  582.     if {$tcl_platform(platform) == "windows"} {
  583.         if {[dde services TclEval $tclshInterp] == ""} {
  584.         alertnote "The remote shell has died, please select a new one."
  585.         unset tclshInterp
  586.         return [tcltk::evaluate $what]
  587.         }
  588.         dde execute TclEval $tclshInterp [list catch $what alpha_result]
  589.         return [dde request TclEval $tclshInterp alpha_result]
  590.     } else {
  591.         catch {send $tclshInterp $what} res
  592.     }
  593.     }
  594.     return $res
  595. }
  596.  
  597. proc tcltk::listInterps {} {
  598.     global tcl_platform
  599.     if {$tcl_platform(platform) == "windows"} {
  600.     set res {}
  601.     foreach service [dde services TclEval ""] {
  602.         lappend res [lindex $service 1]
  603.     }
  604.     return $res
  605.     } else {
  606.     return [winfo interps]
  607.     }
  608. }
  609.  
  610. proc tcltk::findTclshInterp {} {
  611.     global tclshInterp tclshSigs tclshSig
  612.     set old [tcltk::listInterps]
  613.     set shel [listpick -p "Use which Tcl shell?" [concat $old \
  614.       [list "------------------" "Launch new shell"]]]
  615.     if {$shel == "Launch new shell"} {
  616.     tcltk::launchNewShell
  617.     } else {
  618.     set tclshInterp $shel
  619.     }
  620. }
  621.  
  622. ## 
  623.  # -------------------------------------------------------------------------
  624.  # 
  625.  # "tcltk::launchNewShell" --
  626.  # 
  627.  #  Startup up a new Tcl shell, ensuring that we can communicate with that
  628.  #  shell.  On Unix/MacOS this should be easy using 'send' or apple-events
  629.  #  respectively.  On Windows we have to set up the new shell as a dde
  630.  #  server.  We do this with the script 'winRemoteShell.tcl'.
  631.  #  
  632.  #  Any extra 'args' passed to this procedure are executed, one by one,
  633.  #  in the new shell.
  634.  # -------------------------------------------------------------------------
  635.  ##
  636. proc tcltk::launchNewShell {args} {
  637.     global tclshInterp tclshSigs tclshSig tcl_platform HOME
  638.     set old [tcltk::listInterps]
  639.     if {$tcl_platform(platform) == "windows"} {
  640.     app::runScript tclsh "Tcl shell" [file join $HOME Tools winRemoteShell.tcl] 1
  641.     } else {
  642.     app::launchElseTryThese $tclshSigs tclshSig "Please locate the remote Tcl application"
  643.     }
  644.     while {[tcltk::listInterps] == $old} {
  645.     update
  646.     }
  647.     set tclshInterp [lremove -l [tcltk::listInterps] $old]
  648.     # We're left with two items
  649.     set tclshInterp [lindex $tclshInterp 0]
  650.     
  651.     if {[llength $args]} {
  652.     foreach arg $args {
  653.         tcltk::evaluate $arg
  654.     }
  655.     }
  656. }
  657.  
  658. # ◊◊◊◊ Quick Find Proc… ◊◊◊◊ #
  659.  
  660. proc procs::quickFindDefn {} {
  661.     Tcl::DblClickHelper [prompt::statusLineComplete "proc" procs::complete]
  662. }
  663.  
  664. if {[info tclversion] < 8.0} {
  665.     proc procs::complete {pref} {
  666.     return [info commands ${pref}*]
  667.     }
  668. } else {
  669.     proc procs::complete {pref} {
  670.     if {[regexp {(.*)([^:]+)$} $pref "" start tail]} {
  671.         set cmds [info commands ${pref}*]
  672.         foreach child [namespace children ::$start] {
  673.         if {[string match "::${tail}*" $child]} {
  674.             foreach cmd [info commands ${start}${child}::*] {
  675.             lappend cmds [string trimleft $cmd :]
  676.             }
  677.         }
  678.         }
  679.         return $cmds
  680.     } else {
  681.         return [info commands ${pref}*]
  682.     }
  683.     }
  684. }
  685.  
  686. # ◊◊◊◊ electric behaviour ◊◊◊◊ #
  687. proc Tcl::electricLeft {} {
  688.     if {[literalChar]} { insertText "\{"; return }
  689.     set pat "\}\[ \t\r\n\]*(else(if)?)\[ \t\r\n\]*\$"
  690.     set p [getPos]
  691.     if { [set res [findPatJustBefore "\}" "$pat" $p word]] == "" } { 
  692.     insertText "\{"
  693.     return
  694.     }
  695.     # we have an if/else(if)/else
  696.     switch -- $word {
  697.     "else" {
  698.         replaceText [lindex $res 0] $p "\} $word \{\r"
  699.         bind::IndentLine
  700.     }
  701.     "elseif" {
  702.         replaceText [lindex $res 0] $p "\} $word \{"
  703.     }
  704.     }
  705. }
  706.     
  707. proc Tcl::electricRight {} {
  708.     if {[literalChar]} { insertText "\}"; return }
  709.     set p [getPos]
  710.     if { [regexp "\[^ \t\]" [getText [lineStart $p] $p]] } {
  711.     insertText "\}"
  712.     blink [matchIt "\}" [pos::math $p - 1]]
  713.     return
  714.     }
  715.     set start [lineStart $p]
  716.     insertText "\}"
  717.     createTMark tcl_er [getPos]
  718.     backwardChar
  719.     bind::IndentLine
  720.     gotoTMark tcl_er ; removeTMark tcl_er
  721.     bind::CarriageReturn
  722.     blink [matchIt "\}" [pos::math $start - 1]]
  723. }
  724.  
  725. ## 
  726.  # -------------------------------------------------------------------------
  727.  # 
  728.  # "Tcl::correctIndentation" --
  729.  # 
  730.  #  Returns the correct indentation for the line containing $pos, if that
  731.  #  line were to contain ordinary characters only.  It is the 
  732.  #  responsibility of the calling procedure to ensure that if we are to
  733.  #  insert/have a line already, that that information is taken into
  734.  #  account, by passing in the argument 'next'
  735.  # -------------------------------------------------------------------------
  736.  ##
  737. proc Tcl::correctIndentation {pos {next ""}} {
  738.     global indent_amounts indentSlashEndLines
  739.     # preliminaries
  740.     if {[pos::compare [set beg [lineStart $pos]] == [minPos]]} { return 0 }
  741.     # if the current line is a comment, we have to check some
  742.     # special cases
  743.     if {[string index $next 0] == "\#"} {
  744.     set p [prevLineStart $beg]
  745.     if {[catch {set p [search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^ \t\r\n\]" \
  746.       [pos::math $beg - 1]]}]} {
  747.         # check for search bug at beginning of file.
  748.         if {[pos::compare $p == [minPos]]} {
  749.         if {[getText [minPos] [pos::math [minPos] + 2]] == "\#\#"} {
  750.             if {([string range $next 0 1] != "\#\#")} {
  751.             return 1
  752.             } else {
  753.             return 0
  754.             }
  755.         }
  756.         }
  757.         return 0
  758.     }
  759.     set prev [pos::math [lindex $p 1] - 1]
  760.     set p [lindex $p 0]
  761.     if {[lookAt $prev] != "\#" || ($beg == [minPos])} {
  762.         # not a comment, so indent with code
  763.     } else {
  764.         set lwhite [posX $prev]
  765.         # it's a comment
  766.         if {[getText $prev [pos::math $prev + 2]] == "\#\#" && \
  767.           [lookAt [pos::math $prev + 2]] != "\#" \
  768.           && ([string range $next 0 1] != "\#\#")} {
  769.         # it's a comment paragraph
  770.         incr lwhite 
  771.         }
  772.     }
  773.     }
  774.     set next [string index $next 0]
  775.     if {![info exists lwhite]} {
  776.     if {![catch {search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^\# \t\r\n\]" [pos::math $beg - 1]} lst]} {
  777.         # Find the last non-comment line and get its leading whitespace    
  778.         set lwhite [posX [pos::math [lindex $lst 1] - 1]]
  779.         set pe1 [lookAt [pos::math $beg - 2]]
  780.         set lst [lindex $lst 0]
  781.         set lastC [lookAt [lindex [search -s -f 0 -r 1 -i 0 -m 0 "\[^ \t\r\n\]" [pos::math [nextLineStart $lst] - 1]] 0]]
  782.         if {$next == "\}"} {
  783.         incr lwhite $indent_amounts(-2)
  784.         set pe2 [lookAt [pos::math [prevLineStart $beg] - 2]]
  785.         if {$pe1 == "\\"} {
  786.             incr lwhite $indent_amounts(1)
  787.         } else {
  788.             if {$pe2 == "\\"} {
  789.             incr lwhite $indent_amounts(-1)
  790.             }
  791.         }
  792.         if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  793.         } else { 
  794.         if {$pe1 == "\\"} {
  795.             if {[lookAt [pos::math [prevLineStart $beg] - 2]] != "\\"} {
  796.             incr lwhite $indent_amounts($indentSlashEndLines)
  797.             }
  798.         } else {
  799.             if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  800.             if {[lookAt [pos::math $lst - 2]] == "\\"} {
  801.             incr lwhite $indent_amounts(-$indentSlashEndLines)
  802.             }
  803.         }
  804.         }
  805.     } else {
  806.         # basically failed in all the above, so keep current indentation
  807.         set lwhite [posX [text::firstNonWsLinePos $beg]]
  808.     }
  809.     }
  810.     return [expr {$lwhite > 0 ? $lwhite : 0}]
  811. }
  812.  
  813. ## 
  814.  # -------------------------------------------------------------------------
  815.  #   
  816.  # "Tcl::indentLine" --
  817.  #  
  818.  #  Indentation for Tcl mode.  Better and faster than the generic procedure
  819.  # -------------------------------------------------------------------------
  820.  ##
  821. proc Tcl::indentLine {} {
  822.     set beg [lineStart [getPos]]
  823.     set text [getText $beg [nextLineStart $beg]]
  824.     regexp "^\[ \t\]*" $text white
  825.     set next [pos::math $beg + [string length $white]]
  826.     set nextp [pos::math $next + 2]
  827.     if {[pos::compare $nextp > [maxPos]]} {
  828.     set nextp [maxPos]
  829.     }
  830.     set lwhite [Tcl::correctIndentation [getPos] [getText $next $nextp]]
  831.     
  832.     set lwhite [text::indentOf $lwhite]
  833.     if {$white != $lwhite} {
  834.     replaceText $beg $next $lwhite
  835.     }
  836.     goto [pos::math $beg + [string length $lwhite]]
  837. }
  838. # ◊◊◊◊ Tcl Menu support ◊◊◊◊ #
  839.  
  840. proc procs::reformatEnclosing {pos} {
  841.     set p [procs::findEnclosing $pos "proc|((itcl::)?(body|configbody))" 0 1]
  842.     eval select $p
  843.     ::indentRegion
  844. }
  845.  
  846. proc procs::loadEnclosing {pos} {
  847.     if {[catch {procs::findEnclosing $pos "proc|((itcl::)?(body|configbody))" 0 1} p]} {
  848.     evaluateLine $pos
  849.     } else {
  850.     eval select $p
  851.     if {[catch {uplevel \#0 evaluate} err]} {
  852.         if {[regexp {can't create procedure "(.*)": unknown namespace} $err "" pr]} {
  853.         if {[dialog::yesno "The procedure '$pr' couldn't be loaded, because\
  854.           it is in an unknown namespace.  Shall I create the namespace and\
  855.           try again?"]} {
  856.             ensureNamespaceExists $pr
  857.             return [procs::loadEnclosing $pos]
  858.         }
  859.         }
  860.     }
  861.     }
  862.     goto $pos
  863. }
  864.  
  865. proc procs::findDefinition {} {
  866.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  867.     set func [listpick -L $sel -p {Proc?} [lsort -ignore [info procs]]]
  868.     } else {
  869.     set func [listpick -p {Proc?} [lsort -ignore [info procs]]]
  870.     }
  871.     
  872.     editMark [procs::find $func] $func
  873. }
  874.  
  875. ## 
  876.  # -------------------------------------------------------------------------
  877.  # 
  878.  # "insertDivider" --
  879.  # 
  880.  #  Modified from Vince's original to allow you to just select part of
  881.  #  an already written comment and turn it into a Divider. -trf
  882.  # -------------------------------------------------------------------------
  883.  ##
  884. proc insertDivider {} {
  885.     if {[isSelection]} {
  886.     set enfoldThis [getSelect]
  887.     beginningOfLine
  888.     killLine
  889.     insertText "# ◊◊◊◊ $enfoldThis ◊◊◊◊ #"
  890.     return
  891.     } 
  892.     elec::Insertion "# ◊◊◊◊ •• ◊◊◊◊ #"
  893. }
  894.  
  895. # ◊◊◊◊ Info providers ◊◊◊◊ #
  896. #===============================================================================
  897.  
  898.  
  899. proc Tcl::DblClick {from to shift option control} {
  900.     
  901.     # if cmd and cntrl were pressed, we look to select part of
  902.     # a combination word (less any leading dollar sign) -trf
  903.     if {$control != 0} {
  904.     set clickedPos [getPos]    
  905.     if {[lookAt $from] == "\$"} {
  906.         set from [pos::math $from + 1]
  907.     } 
  908.     set sel_start $clickedPos 
  909.     set selStartNotDetermined 1
  910.     while {$selStartNotDetermined && ([pos::math $sel_start > $from])} {
  911.         set char [lookAt $sel_start] 
  912.         if {[regexp {_} $char]} {
  913.         set sel_start [pos::math $sel_start + 1]
  914.         set selStartNotDetermined 0
  915.         } elseif {[regexp {[A-Z]} $char]} {
  916.         set selStartNotDetermined 0
  917.         } else {
  918.         set sel_start [pos::math $sel_start -1]
  919.         } 
  920.     }
  921.     set sel_end   $clickedPos 
  922.     set selEndNotDetermined 1
  923.     while {$selEndNotDetermined && ([pos::math $sel_end <= $to])} {
  924.         set char [lookAt $sel_end] 
  925.         if {[regexp "\[A-Z_ \t\r\]" $char]} {
  926.         set selEndNotDetermined 0
  927.         } else {
  928.         set sel_end [pos::math $sel_end + 1]
  929.         } 
  930.     }
  931.     select $sel_start $sel_end 
  932.     return
  933.     } 
  934.     
  935.     # otherwise, we try to impart some extra info
  936.     select $from $to
  937.     
  938.     if {[catch {Tcl::DblClickHelper [getSelect]}]} {
  939.     message "No docs $shift $control $option"
  940.     }
  941. }
  942.  
  943.  
  944. # Now finds commands in Alpha Commands,
  945. # which has a <cr> immediately after them, e.g. beep, ticks.
  946. proc Tcl::DblClickHelper {text} {
  947.     global HOME auto_index auto_path
  948.     # Is it a loadable proc?
  949.     if {[string length [set f [procs::find $text]]]} {
  950.     if {[editMark $f $text]} {
  951.         # some marking schemes commonly used for Tcl modes
  952.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}" [minPos]] 0]
  953.     }
  954.     return
  955.     }
  956.     
  957.     if {[info exists "auto_index($text)"]} {
  958.     if {[editMark "$auto_index($text)" $text]} {
  959.         # some marking schemes commonly used for Tcl modes
  960.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}" [minPos]] 0]
  961.     }
  962.     return
  963.     }
  964.     # Is it a built-in Alpha command?
  965.     set lines [grep "^• $text\( |\$)" [file join $HOME Help "Alpha Commands"]]
  966.     if {[string length $lines]} {
  967.     if {[catch {editMark [file join $HOME Help "Alpha Commands"] $text}]} {
  968.         # mark failed for some reason, but we have the line number
  969.         # anyway.
  970.         file::openQuietly [file join $HOME Help "Alpha Commands"]
  971.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  972.     }
  973.     setWinInfo read-only 1
  974.     return
  975.     }
  976.     # Is it a core Tcl command?
  977.     set lines [grep "^     $text -" [file join $HOME Help "Tcl Commands"]]
  978.     if {[string length $lines]} {
  979.     if {[catch {editMark [file join $HOME Help "Tcl Commands"] $text}]} {
  980.         # mark failed for some reason, but we have the line number
  981.         # anyway.
  982.         file::openQuietly [file join $HOME Help "Tcl Commands"]
  983.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  984.     }
  985.     setWinInfo read-only 1
  986.     return
  987.     }
  988.     # Is it a global variable?
  989.     if {[llength [info globals [string trimleft $text {$}]]]==1} {
  990.     showVarValue [string trimleft $text {$}]
  991.     return
  992.     }
  993.     # (becoming desperate) is it a mark in the current file?
  994.     if {[lsearch [getNamedMarks -n] ${text}] != -1} {
  995.     gotoMark $text
  996.     return
  997.     }
  998.     error ""
  999. }
  1000.  
  1001. #############################################################################
  1002. #  Report the current value of a global variable, chosen interactively
  1003. #  from a list of all active variables.
  1004. #
  1005. #  If the variable is an array, or its value is too big to fit in an 
  1006. #  alertnote, then its contents are listed in a new window, otherwise 
  1007. #  the variable's value is displayed in an alertnote.
  1008. #
  1009. proc getVarValue {} {
  1010.     if {[catch {getText [getPos] [selEnd]} def]} {set def ""}
  1011.     set var [getVarFromList $def]
  1012.     if {[string length $var] == 0} return
  1013.     showVarValue $var
  1014. }
  1015.  
  1016. if {[info tclversion] < 8.0} {
  1017.     
  1018.     proc getVarFromList {{def ""}} {
  1019.     return [listpick -p {Which var?} -L $def [lsort -ignore [info globals]]]
  1020.     }
  1021.     
  1022. } else {
  1023.     
  1024.     proc getVarFromList {{def ""}} {
  1025.     set ns "[namespace qualifiers $def]"
  1026.     set def [namespace tail $def]
  1027.     
  1028.     set items {}
  1029.     foreach var [info vars "${ns}::*"] {
  1030.         lappend items [namespace tail $var]
  1031.     }
  1032.     foreach space [namespace children $ns] {
  1033.         lappend items "[namespace tail $space]::"
  1034.     }
  1035.     
  1036.     set items [concat "::" [lsort -ignore $items]]
  1037.     set var [listpick -p "Which var in namespace ${ns}::?" -L $def $items]
  1038.     if {$var == "::"} {
  1039.         set var [getVarFromList $ns]
  1040.     } elseif {[namespace qualifiers $var] != ""} {
  1041.         set var [getVarFromList "${ns}::${var}"]
  1042.     } else {
  1043.         set var "${ns}::${var}"
  1044.     }
  1045.     return $var
  1046.     }
  1047. }
  1048.  
  1049. #############################################################################
  1050. #  Report the current value of a global variable, chosen interactively
  1051. #  from a list of all active variables.
  1052. #
  1053. #  If the variable is an array, or its value is too big to fit in an 
  1054. #  alertnote, then its contents are listed in a new window, otherwise 
  1055. #  the variable's value is displayed in an alertnote.
  1056. #
  1057. proc showVarValue {var} {
  1058.     global $var
  1059.     if {![array exists $var]} {
  1060.         viewValue $var [set $var]
  1061.     } else {
  1062.     new -n "* $var *" -info [listArray $var]
  1063.     # if 'shrinkWindow' is loaded, call it to trim the output window.
  1064.     catch {shrinkWindow 2}
  1065.     }
  1066. } 
  1067.  
  1068. #############################################################################
  1069. #  List the name and value of each element of the array $arrName.
  1070. #  (Convenient to use as a shell command.)
  1071. #
  1072. proc listArray {arrName} {
  1073.     global $arrName
  1074.     if {[array exists $arrName]} {
  1075.     set lines {}
  1076.         foreach nm [array names $arrName] {
  1077.             lappend lines "\"$nm\"\t\{[set ${arrName}($nm)]\}"
  1078.         }
  1079.         return [join $lines \r]
  1080.     } else {
  1081.         alertnote "\"$arrName\" doesn't exist in this context"
  1082.     }
  1083. }
  1084.  
  1085. # ◊◊◊◊ Marking ◊◊◊◊ #
  1086.  
  1087. ## 
  1088.  # -------------------------------------------------------------------------
  1089.  #     
  1090.  # "Tcl::parseFuncs" --
  1091.  #    
  1092.  # This proc is called by the "braces"    pop-up.    It returns a dynamically
  1093.  # created, alphabetical, list of "pseudo-marks".
  1094.  #    
  1095.  #    Author:    Tom Fetherston
  1096.  # -------------------------------------------------------------------------
  1097.  ## called by the "{}" button
  1098. proc Tcl::parseFuncs {} {
  1099.     global TclmodeVars
  1100.     set end [maxPos]
  1101.     set pos [minPos]
  1102.     set l {}
  1103.     set markExpr "^\[ \t\]*(itcl(::|_))?(class|body|proc|method|(config)?body)\[ \t\]"
  1104.     set appearanceList {}
  1105.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  1106.     set start [lindex $res 0]
  1107.     set end [nextLineStart $start]
  1108.     set t [getText $start $end]
  1109.     append t "\}"
  1110.     set argLabel {}
  1111.     regsub "^itcl(::|_)" [lindex $t 0] "" what
  1112.     switch -- [lindex $t 0] {
  1113.         "proc" {
  1114.         append argLabel [set word [lindex $t 1]]
  1115.         #get the list of arguments
  1116.         set argsList [lindex $t 2]
  1117.         if {[llength $argsList] > 0} {
  1118.             append argLabel " \{"
  1119.             foreach arg $argsList {
  1120.             if {[llength $arg] == 2 } {
  1121.                 append argLabel "¿"
  1122.             } elseif {[set arg] != "args"} {
  1123.                 append argLabel "•"
  1124.             } else {
  1125.                 append argLabel "…"
  1126.             }
  1127.             }
  1128.             append argLabel "\}"                    
  1129.         } 
  1130.         }
  1131.         default {
  1132.         append argLabel [set word [lindex $t 1]]
  1133.         }
  1134.     }
  1135.     if {[info exists cnts($word)]} {
  1136.         # This section handles duplicate. i.e., overloaded names
  1137.         set cnts($word) [expr {$cnts($word) + 1}]
  1138.         set tailOfTag($word) " ($cnts($word) of $cnts($word))"
  1139.         # we want the tag to point to its last occurence 
  1140.         # because in Tcl, that proc will be 'in-force' when the
  1141.         # file is loaded.
  1142.         set indx($word) [lineStart [pos::math $start - 1]]
  1143.     } else {
  1144.         #SO do: remember the following
  1145.         set cnts($word) 1
  1146.         # if this is the only occurence of this proc, remember where it starts
  1147.         set indx($word) [lineStart [pos::math $start - 1]]
  1148.     }
  1149.     #associate name and tag
  1150.     set tag($word) $argLabel
  1151.     
  1152.     #advance pos to where we want to start the next search from
  1153.     set pos $end
  1154.     }
  1155.     
  1156.     set rtnRes {}
  1157.     
  1158.     if {[info exists indx]} {
  1159.     foreach hn [lsort -ignore [array names indx]] {
  1160.         set next [nextLineStart $indx($hn)]
  1161.         set completeTag [set tag($hn)]
  1162.         if {[info exists tailOfTag($hn)]} {
  1163.         append completeTag [set tailOfTag($hn)]
  1164.         }
  1165.         
  1166.         lappend rtnRes $completeTag $next
  1167.     }
  1168.     }
  1169.     return $rtnRes 
  1170. }
  1171.  
  1172. # called by the "M" button
  1173. proc Tcl::MarkFile {} {
  1174.     global structuralMarks
  1175.     set end [maxPos]
  1176.     set pos [minPos]
  1177.     set l {}
  1178.     if {$structuralMarks} {
  1179.     set markExpr {^;?[     ]*(itcl(::|_))?(class|namespace eval|proc|method|(config)?body|# ◊◊◊◊)[     ]}
  1180.     } else {
  1181.     set markExpr {^;?[     ]*(itcl(::|_))?(class|namespace eval|proc|method|(config)?body)[     ]}
  1182.     }
  1183.     set class ""
  1184.     set hasMarkers 0
  1185.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  1186.     set start [lindex $res 0]
  1187.     set end [nextLineStart $start]
  1188.     set t [string trim [getText $start $end] ";"]
  1189.     append t "\}"
  1190.     if {[catch {lindex $t 0}]} {
  1191.         # wasn't a well formed list
  1192.         set pos $end
  1193.         continue
  1194.     }
  1195.     regsub "^itcl(::|_)" [lindex $t 0] "" what
  1196.     switch -glob $what {
  1197.         "proc" -
  1198.         "configbody" { set text [lindex $t 1] }
  1199.         "method" { set text ${class}::[lindex $t 1] }
  1200.         "body" { 
  1201.         regexp {[a-zA-Z_][a-zA-Z_/0-9]*::[a-zA-Z_][a-zA-Z_/0-9]* } \
  1202.           "[lindex $t 1] " text
  1203.         }
  1204.         "namespace" {
  1205.         set ns [lindex $t 2]
  1206.         if {[regexp {[^a-zA-Z0-9]} $ns]} {
  1207.             set pos $end
  1208.             continue
  1209.         }
  1210.         set text "${ns} 111" 
  1211.         }
  1212.         "*class" { 
  1213.         set class [lindex $t 1]
  1214.         set text "${class} 000" 
  1215.         }
  1216.         "#" { 
  1217.         regexp "# ◊◊◊◊ (.*) ◊◊◊◊" $t all text
  1218.         if {[regexp "^(    )|(    )# ◊◊◊◊ " $t]} {
  1219.             set text " •$text"
  1220.         } else {
  1221.             set text "•$text"
  1222.         }                
  1223.         set hasMarkers 1
  1224.         }
  1225.     }
  1226.     set pos $end
  1227.     if {$structuralMarks} {
  1228.         lappend asEncountered $text
  1229.         set arr inds
  1230.     } else {
  1231.         if {[string index $t 0] == ";"} {
  1232.         set arr iinds
  1233.         } else {
  1234.         set arr inds
  1235.         }
  1236.     }
  1237.     set ${arr}($text) [lineStart [pos::math $start - 1]]
  1238.     }
  1239.     
  1240.     set already ""
  1241.     set class "#"
  1242.     foreach arr {inds iinds} {
  1243.     if {[info exists $arr]} {
  1244.         if {$arr == "iinds"} {
  1245.         setNamedMark "-" 0 0 0
  1246.         }
  1247.         if {$structuralMarks} {
  1248.         set order $asEncountered
  1249.         } else {
  1250.         set order [lsort -ignore [array names $arr]]
  1251.         }
  1252.         foreach f $order {
  1253.         if {[set el [set ${arr}($f)]] != 0} {
  1254.             set next [nextLineStart $el]
  1255.         } else {
  1256.             set next 0
  1257.         } 
  1258.         
  1259.         if { [string first "000" $f] != -1 } {
  1260.             set ff "Class '[set class [lindex $f 0]]'"
  1261.         } elseif { [string first "111" $f] != -1 } {
  1262.             set ff "Namespace '[set class [lindex $f 0]]'"
  1263.         } elseif { [string first "${class}::" $f] == 0 } {
  1264.             set ff [string range $f [string length $class] end]
  1265.         } else {
  1266.             set ff $f
  1267.         }
  1268.         while { [lsearch -exact $already $ff] != -1 } {
  1269.             set ff "$ff "
  1270.         }
  1271.         lappend already $ff
  1272.         if {$hasMarkers && ![string match "•*" $ff] } {
  1273.             set ff " $ff"
  1274.         } 
  1275.         setNamedMark $ff $el $next $next
  1276.         }
  1277.     }
  1278.     }
  1279. }
  1280.  
  1281. # ◊◊◊◊ Misc. ◊◊◊◊ #
  1282.  
  1283. ## 
  1284.  # -------------------------------------------------------------------------
  1285.  # 
  1286.  # "bind::tclContinueComment" --
  1287.  # 
  1288.  #  exploits a "feature" in the code that makes a new line a comment whenever 
  1289.  #  you are 'inside' a comment. This proc puts a pound sign at the end of the 
  1290.  #  current line, backsteps, and creates a new line. With the pound sign 
  1291.  #  present you are considered to be in a comment, so the bind::CarriageReturn 
  1292.  #  in the proc, and any subsequent bind::CarriageReturn called by a press of  
  1293.  #  the return key will provide another comment line automatically until the 
  1294.  #  pound sign at the end of the line is removed (killLine is handy for this).
  1295.  # -------------------------------------------------------------------------
  1296.  ##
  1297. proc bind::tclContinueComment {} {
  1298.     insertText {#}
  1299.     backwardChar
  1300.     bind::CarriageReturn
  1301.     deleteChar
  1302. }
  1303. Bind '\r' <c> bind::tclContinueComment Tcl
  1304.  
  1305. proc evaluateLine { pos } {
  1306.     goto $pos
  1307.     beginningLineSelect
  1308.     endLineSelect
  1309.  
  1310.     uplevel \#0 evaluate
  1311. }
  1312.  
  1313. #◊◊◊◊> 
  1314.  
  1315. tcltk::evaluateRemoteSynchronise
  1316.  
  1317.